home *** CD-ROM | disk | FTP | other *** search
/ QRZ! Ham Radio 1 / QRZ Ham Radio Callsign Database - December 1993.iso / ucsd / packet / tcpip / g0bsx / servertr.z / servertr / SERVERS / AGE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-07-27  |  4.6 KB  |  173 lines
  1.  program AGE ;
  2. { By Peter Meiring, G0BSX. All rights Reserved.                              }
  3. { Version 1.0:                                                               }
  4. { This is a program will scan the Mail files and delete those older than     }
  5. { a specified number of days. }
  6.  
  7. { file format: MAIL files. }
  8. { From g0bsx@g0bsx.ampr.org Sun Jun 24 19:21:50 1990 }
  9. { Received: from g0bsx by g0bsx.ampr.org with SMTP   }
  10. {        id AA27765 ; Sun, 24 Jun 90 19:21:49 utc    }
  11. { Date: Sun, 24 Jun 90 19:23:55 GMT                  }
  12. { Message-Id: <53@g0bsx.ampr.org>                    }
  13. { From: g0bsx@g0bsx.ampr.org (Peter Meiring)         }
  14. { To: g0bsx%mac@g0bsx                                }
  15. { Subject: test 5                                    }
  16. {                                                    }
  17. { Message Text.                                      }
  18.  
  19. const
  20.       Version    = 'Version 1.0 (c) Peter Meiring, G0BSX, June 1990.';
  21.       MAILDir    = '\SPOOL\MAIL\';
  22.       AreaFname  = '\SPOOL\AREAS';
  23.       tab = #$09;
  24.       space = #$20;
  25.  
  26. type WorkString = string[255];
  27.      String40   = string[40];
  28.  
  29. var
  30.     FP : text;
  31.     line : WorkString;
  32.     w1,w2 : String40;
  33.  
  34. function word( n : integer; s : WorkString) : string40;
  35.  
  36. var c,p,q : integer;
  37.     t,a : WorkString;
  38.  
  39. begin
  40.   t := s;
  41.   for c := 1 to n do
  42.     if length(t) > 0 then begin
  43.       while (length(t) > 1) and ((t[1] = space)or(t[1] = Tab)) do
  44.         t := copy( t, 2, length(t)-1);
  45.       if (t = space) or (t = tab) then begin
  46.         t := '';
  47.         a := '';
  48.       end;
  49.       if t <> '' then
  50.         p := pos( space, t);
  51.       q := pos( tab, t);
  52.       if ((p > q) and (q > 0)) or ((q > p) and (p = 0)) then p := q;
  53.       if p <> 0 then begin
  54.         a := copy( t, 1, p-1);
  55.         t := copy( t, p+1, length(t) - p)
  56.       end else begin
  57.         a := t;
  58.         t := ''
  59.       end
  60.   end;
  61.   word := a
  62. end;
  63.  
  64.  
  65. procedure process(area, sdays : string40);
  66.  
  67. var mailfp : text;
  68.     outfp  : text;
  69.     age,n,y,m,d,a  : integer;
  70.     copying : boolean;
  71.     line : workstring;
  72.  
  73. function Now : integer ;
  74.  
  75. type
  76.   regpack = record
  77.               ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
  78.             end;
  79.  
  80. var
  81.   recpack:          regpack;             {assign record}
  82.   ah,al,ch,cl,dh:   byte;
  83.   days,day,month,year : integer;
  84.  
  85. begin
  86.   ah := $2c;                             {initialize correct registers}
  87.   with recpack do
  88.   begin
  89.     ax := $2a shl 8;
  90.   end;
  91.   MsDos(recpack);                        { call function }
  92.   with recpack do
  93.   begin
  94.     year := cx;
  95.     day := dx mod 256;
  96.     month := dx shr 8;
  97.   end;
  98.   year := year-1990;
  99.   days := year*365 + year div 4  + (275*month) div 9 - 2*((month+9) div 12 )
  100.          + day - 30;
  101.   if (year mod 4 = 0) and (month > 2) then days := succ(days);
  102.   Now := days
  103. end;
  104.  
  105. begin
  106.   val(sdays,age,n);
  107.   writeln('Current day: ',now);
  108.   writeln('Aging bulletin area: ',area,'. Maximum age = ',age,' days.');
  109.   assign(mailfp, MAILDir+area+'.TXT');
  110.   {$I-}
  111.   reset(mailfp);
  112.   if IOResult <> 0 then begin
  113.     writeln('Area empty');
  114.     exit;
  115.   end;
  116.   {I+}
  117.   assign(outfp, MAILDir+area+'.TMP');
  118.   rewrite(outfp);
  119.   copying := false;
  120.   while not eof(mailfp) do begin
  121.     readln(mailfp, line);
  122.     if pos('From ',Line) = 1 then begin
  123.       val(word(7,line),y,n);
  124.       val(word(5,line),d,n);
  125.       if      pos('Jan',line)>0 then m := 1
  126.       else if pos('Feb',line)>0 then m := 2
  127.       else if pos('Mar',line)>0 then m := 3
  128.       else if pos('Apr',line)>0 then m := 4
  129.       else if pos('May',line)>0 then m := 5
  130.       else if pos('Jun',line)>0 then m := 6
  131.       else if pos('Jul',line)>0 then m := 7
  132.       else if pos('Aug',line)>0 then m := 8
  133.       else if pos('Sep',line)>0 then m := 9
  134.       else if pos('Oct',line)>0 then m := 10
  135.       else if pos('Nov',line)>0 then m := 11
  136.       else if pos('Dec',line)>0 then m := 12;
  137.       y := y-1990;
  138.       a := y*365 + y div 4  + (275*m) div 9 - 2*((m+9) div 12 ) + d - 30;
  139.       if (y mod 4 = 0) and (m > 2) then a := succ(a);
  140.       write('Age ',a,' ',line);
  141.       if now - a > age then begin
  142.         copying := false;
  143.         write(' - deleting');
  144.       end
  145.       else begin copying := true;
  146.          writeln(' - copying')
  147.       end
  148.     end;
  149.     if copying then writeln(outfp,line)
  150.   end;
  151.   close(outfp);
  152.   erase(mailfp);
  153.   rename(Outfp, MAILDir+area+'.TXT')
  154. end;
  155.  
  156.  
  157.  
  158. begin
  159.   writeln('G0BSX  NOS mailbox bulletin areas maintenance program.');
  160.   writeln(Version);
  161.   assign(fp, AreaFName);
  162.   {$I-}
  163.   reset(fp);
  164.   if IOResult <> 0 then begin
  165.     writeln('*** Error accessing: ',AreaFName);
  166.     halt
  167.   end;
  168.   {I+}
  169.   while not EOF(fp) do begin
  170.     readln(fp, line);
  171.     if line <> '' then process( word(1,line), word(2,line));
  172.   end
  173. end.